home *** CD-ROM | disk | FTP | other *** search
/ MacGames Sampler / PHT MacGames Bundle.iso / MacSource Folder / Samples from the CD / Editors / emacs / Emacs-1.14b1 / lisp / mac / apple-events.el < prev    next >
Encoding:
Text File  |  1994-03-23  |  7.7 KB  |  225 lines  |  [TEXT/EMAC]
  1. ;;;
  2. ;;; This file is part of a Macintosh port of GNU Emacs.
  3. ;;; Copyright (C) 1993, 1994 Marc Parmet.  All rights reserved.
  4. ;;;
  5. ;;; GNU Emacs is distributed in the hope that it will be useful,
  6. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  7. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  8. ;;; GNU General Public License for more details.
  9. ;;;
  10.  
  11. ;;;
  12. ;;; Utilities for Apple event calls
  13. ;;;
  14.  
  15. (defmacro unix-filename-to-FSSpec (filename spec)
  16.   (` (let ((temp (unix-filename-to-FSSpec-internal (, filename))))
  17.        (setq (, spec) (car temp))
  18.        (cdr temp))))
  19.  
  20. (defun deref (address)
  21.   (extract-internal address 0 'unsigned-long))
  22.  
  23. (defun throw-err (err)
  24.   (if (not (zerop err))
  25.       (throw 'panic err)))
  26.  
  27. ;;;
  28. ;;; A convenient way to create Apple events to a specific target
  29. ;;;
  30.  
  31. (defun ae-create-apple-event-internal (targetID eventClass eventID)
  32.   (let* ((target (make-string sizeof-AEDesc 0))
  33.          have-target
  34.          (event (make-string sizeof-AppleEvent 0))
  35.          have-event
  36.          (actualSize (make-string 4 0))
  37.          (resultType (make-string 4 0))
  38.          (transactionID (make-string 4 0))
  39.          (result
  40.           (catch 'panic
  41.             (throw-err (AECreateDesc typeApplSignature targetID 4 target))
  42.             (setq have-target t)
  43.             (throw-err (AECreateAppleEvent eventClass eventID target
  44.                                            kAutoGenerateReturnID
  45.                                            kAnyTransactionID event))
  46.             (setq have-event t)
  47.             (throw-err (AEGetAttributePtr event keyReturnIDAttr typeLongInteger
  48.                                           resultType transactionID 4 actualSize))
  49.             noErr)))
  50.     (if have-target (AEDisposeDesc target))
  51.     (if (zerop result)
  52.         (cons result (cons event (extract-internal transactionID 0 'long)))
  53.       (cons result (cons nil nil)))))
  54.  
  55. (defmacro ae-create-apple-event (targetID eventClass eventID event transactionID)
  56.   (` (let ((temp (ae-create-apple-event-internal (, targetID)
  57.                                                  (, eventClass) (, eventID))))
  58.        (setq (, event) (car (cdr temp)))
  59.        (setq (, transactionID) (cdr (cdr temp)))
  60.        (car temp))))
  61.  
  62. (defvar ae-history nil "A list of Apple events sent from Emacs.     This list is used to associate replies.")
  63.  
  64. (defun ae-have-required-parameters (event)
  65.   (let* ((actualSize (make-string 4 0))
  66.          (returnedType (make-string 4 0))
  67.          (data (make-string 0 0))
  68.          (err (AEGetAttributePtr event keyMissedKeywordAttr typeWildCard
  69.                                  returnedType data 0 actualSize)))
  70.     (cond
  71.      ((= err errAEDescNotFound)
  72.       noErr)
  73.      ((= err noErr)
  74.       errAEEventNotHandled)
  75.      (t
  76.       err))))
  77.  
  78. (defun short-time-string ()
  79.   "Returns a string representing the time of day."
  80.   (let* ((s (current-time-string))
  81.          (blank-3 10)
  82.          (blank-4 19))
  83.     (substring s (1+ blank-3) blank-4)))
  84.  
  85. (defun insert-reply (&rest s)
  86.   (let ((errors-buffer (get-buffer-create "*replies*"))
  87.         (original-window (selected-window)))
  88.     (if (not (get-buffer-window errors-buffer))
  89.         (let ((errors-window 
  90.                (if (eq (next-window) original-window)
  91.                    (split-window original-window
  92.                                  (- (window-height (selected-window)) 8))
  93.                  (display-buffer errors-buffer))))
  94.           (set-window-buffer errors-window errors-buffer)))
  95.     (select-window (get-buffer-window errors-buffer))
  96.     (set-buffer errors-buffer)
  97.     (goto-char (point-max))
  98.     (apply (function insert) s)
  99.     (select-window original-window)))
  100.  
  101. (defun do-ae-answer (event reply refCon)
  102.   (let* ((actualSize (make-string 4 0))
  103.          (resultType (make-string 4 0))
  104.          (transactionID-string (make-string 4 0))
  105.          (err (AEGetAttributePtr event keyReturnIDAttr typeLongInteger
  106.                                  resultType transactionID-string 4 actualSize)))
  107.     (if (not (zerop err))
  108.         (insert-reply "Received a reply, but cannot determine original request\n")
  109.       (let* ((transactionID-number (extract-internal transactionID-string 0 'long))
  110.              (history (assoc transactionID-number ae-history)))
  111.         (if (not history)
  112.             (insert-reply "Received a reply with ID "
  113.                           (int-to-string transactionID-number)
  114.                           ", but cannot determine original request\n")
  115.           (let ((handler (cdr (assoc 'handler (cdr history)))))
  116.             (if handler
  117.                 (funcall handler event history)
  118.               noErr)))))))
  119.  
  120. ;;;
  121. ;;; A simple reply handler
  122. ;;;
  123.  
  124. (defun announce-reply (history)
  125.   (let ((description (cdr (assoc 'description (cdr history)))))
  126.     (insert-reply "Reply at " (short-time-string)
  127.                   (if description (concat " to “" description "”") "")
  128.                   ":\n")))
  129.  
  130. (defun do-simple-reply-internal (event history show-all-replies)
  131.   (let* ((error-number-data (make-string 4 0))
  132.          (returnedType (make-string 4 0))
  133.          (actualSize (make-string 4 0))
  134.          (err (AEGetParamPtr event keyErrorNumber typeLongInteger returnedType
  135.                              error-number-data (length error-number-data) actualSize)))
  136.     (cond
  137.      ((zerop err)
  138.       (announce-reply history)
  139.       (let ((error-number (extract-internal error-number-data 0 'long)))
  140.         (insert-reply "     Error " (error-string error-number) "\n"))
  141.       noErr)
  142.      ((= err errAEDescNotFound)
  143.       (if show-all-replies
  144.           (progn
  145.             (announce-reply history)
  146.             (insert-reply "  No data was sent in reply.\n")))
  147.       noErr)
  148.      (t
  149.       (announce-reply history)
  150.       (insert-reply "  Could not read result, got error " (error-string err) ".\n")
  151.       err))))
  152.  
  153. (defun do-simple-reply (event history)
  154.   (do-simple-reply-internal event history t))
  155.  
  156. (defun do-error-reply (event history)
  157.   (do-simple-reply-internal event history nil))
  158.  
  159. (defun error-string (error-number)
  160.   (concat (int-to-string error-number)
  161.           (let ((s (lookup-error-string error-number)))
  162.             (if s (concat ", “" s "”") ""))))
  163.  
  164. (defun report-error-in-message-line (err)
  165.   (if (not (zerop err))
  166.       (let ((error-string (lookup-error-string err)))
  167.         (message (concat "While sending Apple event, got error "
  168.                          (int-to-string err)
  169.                          (if error-string (concat ", “" error-string "”") ""))))))
  170.  
  171. (defun launch-application (name)
  172.   "Launch the application named APPLICATION in ~/etc."
  173.   (let* (target
  174.          event
  175.          have-event
  176.          (reply (make-string sizeof-AppleEvent 0))
  177.          transactionID
  178.          spec
  179.          (alias-string (make-string 4 0))
  180.          alias-handle
  181.          alias-data
  182.          (ae-list (make-string sizeof-AEDescList 0))
  183.          have-ae-list
  184.          (result
  185.           (catch 'panic
  186.             (progn
  187.               (throw-err (ae-create-apple-event "MACS" kAEFinderEvents kAEOpenSelection
  188.                                                 event transactionID))
  189.               (setq have-event t)
  190.               
  191.               (throw-err (unix-filename-to-FSSpec "/bin" spec))
  192.               (throw-err (NewAlias 0 spec alias-string))
  193.               (setq alias-handle (extract-internal alias-string 0 'unsigned-long))
  194.               (HLock alias-handle)
  195.               (let ((alias-size (extract-internal (deref alias-handle) 4 'short)))
  196.                 (setq alias-data (extract-internal (deref alias-handle) 0 'string alias-size )))
  197.               (DisposHandle alias-handle)
  198.               (throw-err (AEPutParamPtr event keyDirectObject typeAlias
  199.                                         alias-data (length alias-data)))
  200.               
  201.               (throw-err (unix-filename-to-FSSpec (concat "/bin/" name) spec))
  202.               (throw-err (NewAliasMinimal spec alias-string))
  203.               (setq alias-handle (extract-internal alias-string 0 'unsigned-long))
  204.               (HLock alias-handle)
  205.               (let ((alias-size (extract-internal (deref alias-handle) 4 'short)))
  206.                 (setq alias-data (extract-internal (deref alias-handle) 0 'string alias-size )))
  207.               (DisposHandle alias-handle)
  208.               (throw-err (AECreateList 0 0 0 ae-list))
  209.               (setq have-ae-list t)
  210.               (throw-err (AEPutPtr ae-list 0 typeAlias alias-data (length alias-data)))
  211.               (throw-err (AEPutParamDesc event keySelection ae-list))
  212.               
  213.               (throw-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
  214.                                  kAENormalPriority kAEDefaultTimeout 0 0))
  215.               (setq ae-history (cons (cons transactionID
  216.                                            (list
  217.                                             (cons 'description (concat "launch " name))))
  218.                                      ae-history))
  219.               noErr))))
  220.     (if have-event (AEDisposeDesc event))
  221.     (if have-ae-list (AEDisposeDesc ae-list))
  222.     result))
  223.     
  224. (AEInstallEventHandler kCoreEventClass kAEAnswer 'do-ae-answer 0 0)
  225.